Shareware Grab Bag/Shareware Grab Bag.iso/007/tsr25src.arc/MAPMEM.PAS

Pascal/Delphi Source File | 1987-06-02 | 30KB | 906 lines

{**************************************************************************
*   Maps system memory blocks for MS/PCDOS 2.0 and higher.                *
*   Also maps expanded memory allocation blocks                           *
*   Copyright (c) 1986 Kim Kokkonen, TurboPower Software.                 *
*   Released to the public domain for personal, non-commercial use only.  *
***************************************************************************
*   version 1.0 1/2/86                                                    *
*   version 1.1 1/10/86                                                   *
*     running under DOS 2.X, where block owner names are unknown          *
*   version 1.2 1/22/86                                                   *
*     a bug in parsing the owner name of the block                        *
*     a quirk in the way that the DOS PRINT buffer installs itself        *
*     minor cosmetic changes                                              *
*   version 1.3 2/6/86                                                    *
*     smarter filtering for processes that deallocate their environment   *
*   version 1.4 2/23/86                                                   *
*     add a map of Expanded memory (EMS) as well                          *
*   version 1.5 2/26/86                                                   *
*     change format of last memory block                                  *
*     change to more reliable scheme of finding first block               *
*       (thanks to Chris Dunford for pointing out a useful                *
*        undocumented DOS function).                                      *
*     support environment lengths up to 32K                               *
*   version 1.6 3/8/86                                                    *
*     support "verbose" output mode                                       *
*       display open file handles                                         *
*       show command line of each block                                   *
*   version 1.7 3/24/86                                                   *
*     work around Turbo 3.00B bug with Delete procedure and length 255    *
*     filter out command lines of programs which relocate over their      *
*       command line at PSP:$80                                           *
*     fix treatment of handle counts from PSP                             *
*     add display of number of memory blocks per PSP to verbose mode      *
*     accept V, -V, or /V for the verbose switch                          *
*   version 1.8 4/20/86                                                   *
*     change verbose mode to show each block individually                 *
*   version 1.9 5/22/86                                                   *
*     synchronize with RELEASE                                            *
*   version 2.0 6/17/86                                                   *
*     synchronize with RELEASE                                            *
*   version 2.1 7/18/86                                                   *
*     wrap long vector lists                                              *
*   version 2.2 3/4/87                                                    *
*     add support for WATCH files                                         *
*   version 2.3 5/1/87                                                    *
*     use in-memory WATCH data                                            *
*     display disabled status of TSRs                                     *
*   version 2.4 5/17/87                                                   *
*     avoid use of EMS call $4B, which doesn't work in many EMS           *
*       implementations                                                   *
*   version 2.5 5/26/87                                                   *
*     correct problem with MAPMEM run in batch file with WATCH            *                                    *
***************************************************************************
*   telephone: [phone], CompuServe: 72457,2131.                      *
*   requires Turbo version 3 to compile.                                  *
*   Compile with mAx dynamic memory = FFFF.                               *
***************************************************************************}

{$P128}

program MapMem;
  {-look at the system memory map using DOS memory control blocks}
const
  Version = '2.5';
  MaxBlocks = 100;            {max number of DOS memory blocks checked}
  MaxVector = $FF;            {highest interrupt vector checked for trapping}

  WatchID = 'TSR WATCHER';    {marking string for WATCH}

  {offsets into resident copy of WATCH.COM for data storage}
  WatchOffset = $81;
  NextChange = $104;
  ChangeVectors = $220;
  OrigVectors = $620;
  CurrVectors = $A20;

type
  Pathname = string[64];
  AllStrings = string[255];

  BlockType = 0..MaxBlocks;
  Block =
  record                      {store info about each memory block as it is found}
    idbyte : Byte;
    mcb : Integer;
    psp : Integer;
    len : Integer;
    psplen : Integer;
    env : Integer;
    cnt : Integer;
  end;
  BlockArray = array[BlockType] of Block;

  registers =
  record
    case Integer of
      1 : (ax, bx, cx, dx, bp, si, di, ds, es, flags : Integer);
      2 : (al, ah, bl, bh, cl, ch, dl, dh : Byte);
  end;

var
  Blocks : BlockArray;
  WatchBlock, BlockNum : BlockType;
  UseHook, Verbose, UseWatch : Boolean;

  procedure Abort(msg : AllStrings);
    {-halt in case of error}
  begin
    WriteLn(msg);
    Halt(1);
  end {Abort} ;

  function StUpcase(s : Pathname) : Pathname;
    {-return the upper case of a string}
  var
    i : Byte;
  begin
    for i := 1 to Length(s) do
      s[i] := UpCase(s[i]);
    StUpcase := s;
  end {stupcase} ;

  procedure FindTheBlocks;
    {-scan memory for the allocated memory blocks}
  const
    MidBlockID = $4D;         {byte DOS uses to identify part of MCB chain}
    EndBlockID = $5A;         {byte DOS uses to identify last block of MCB chain}
  var
    mcbSeg : Integer;         {segment address of current MCB}
    nextSeg : Integer;        {computed segment address for the next MCB}
    gotFirst : Boolean;       {true after first MCB is found}
    gotLast : Boolean;        {true after last MCB is found}
    idbyte : Byte;            {byte that DOS uses to identify an MCB}

    function GetStartMCB : Integer;
      {-return the first MCB segment}
    var
      reg : registers;
    begin
      reg.ah := $52;
      MsDos(reg);
      GetStartMCB := MemW[reg.es:(reg.bx-2)];
    end {getstartmcb} ;

    procedure StoreTheBlock(var mcbSeg, nextSeg : Integer;
                            var gotFirst, gotLast : Boolean);
      {-store information regarding the memory block}
    var
      nextID : Byte;
      pspAdd : Integer;       {segment address of the current PSP}
      mcbLen : Integer;       {size of the current memory block in paragraphs}

    begin

      mcbLen := MemW[mcbSeg:3]; {size of the MCB in paragraphs}
      nextSeg := Succ(mcbSeg+mcbLen); {where the next MCB should be}
      pspAdd := MemW[mcbSeg:1]; {address of program segment prefix for MCB}
      nextID := Mem[nextSeg:0];

      if gotLast or (nextID = EndBlockID) or (nextID = MidBlockID) then begin
        BlockNum := Succ(BlockNum);
        gotFirst := True;
        with Blocks[BlockNum] do begin
          idbyte := Mem[mcbSeg:0];
          mcb := mcbSeg;
          psp := pspAdd;
          env := MemW[pspAdd:$2C];
          len := mcbLen;
          psplen := 0;
          cnt := 1;
        end;
      end;

    end {storetheblock} ;

  begin

    {initialize}
    mcbSeg := GetStartMCB;
    gotFirst := False;
    gotLast := False;
    BlockNum := 0;

    {scan all memory until the last block is found}
    repeat
      idbyte := Mem[mcbSeg:0];
      if idbyte = MidBlockID then begin
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
        if gotFirst then mcbSeg := nextSeg else mcbSeg := Succ(mcbSeg);
      end else if gotFirst and (idbyte = EndBlockID) then begin
        gotLast := True;
        StoreTheBlock(mcbSeg, nextSeg, gotFirst, gotLast);
      end else
        {start block was invalid}
        Abort('corrupted allocation chain or program error');
    until gotLast;

  end {findtheblocks} ;

  function FindMark(markName : AllStrings; markOffset : Integer) : Integer;
    {-find the last memory block matching idstring at offset idoffset}
  var
    b : BlockType;
    MemMark : Boolean;

    function HasIDstring(segment : Integer;
                         idString : AllStrings;
                         idOffset : Integer) : Boolean;
      {-return true if idstring is found at segment:idoffset}
    var
      len : Byte absolute idString;
      tString : AllStrings;
      tlen : Byte absolute tString;

    begin
      tlen := len;
      Move(Mem[segment:idOffset], tString[1], len);
      HasIDstring := (tString = idString);
    end {HasIDstring} ;

  begin
    {scan from the last block down to find the last MARK TSR}
    b := BlockNum;
    MemMark := False;
    repeat
      if Blocks[b].psp = CSeg then
        {assure this program's command line is not matched}
        b := Pred(b)
      else if HasIDstring(Blocks[b].psp, markName, markOffset) then
        {Mark found}
        MemMark := True
      else
        {Keep looking}
        b := Pred(b);
    until (b < 1) or MemMark;

    UseWatch := MemMark;
    FindMark := b;

  end {findmark} ;

  function Cardinal(i : Integer) : Real;
    {-return an unsigned integer 0..65535}
  begin
    if i < 0 then
      Cardinal := 65536.0+i
    else
      Cardinal := i;
  end {cardinal} ;

  procedure StripNonAscii(var t : Pathname);
    {-return an empty string if t contains any non-printable characters}
  var
    ipos : Byte;
    goodname : Boolean;
  begin
    goodname := True;
    for ipos := 1 to Length(t) do
      if (t[ipos] <> #0) and ((t[ipos] < ' ') or (t[ipos] > '}')) then
        goodname := False;
    if not(goodname) then t := '';
  end {stripnonascii} ;

  procedure ShowTheBlocks;
    {-analyze and display the blocks found}
  const
    hookst : string[14] = 'hooked vectors';
    chainst : string[15] = 'chained vectors';
  type
    HexString = string[4];
    Address = record
                offset, segment : Integer;
              end;
    VectorType = 0..MaxVector;
  var
    st, cline : Pathname;
    b : BlockType;
    StLen, DOSv : Byte;
    CommandPSP, WatchPSP : Integer;
    Vectors : array[VectorType] of Address absolute 0 : 0;
    Vtable : array[VectorType] of Real;
    SumNum : BlockType;
    Sum : BlockArray;

    function HexB(b : Byte) : HexString;
      {-return hex representation of byte}
    const
      hc : array[0..15] of Char = '0123456789ABCDEF';
    begin
      HexB := hc[b shr 4]+hc[b and $F];
    end {HexB} ;

    function Hex(i : Integer) : HexString;
      {-return hex representation of integer}
    begin
      Hex := HexB(Hi(i))+HexB(Lo(i));
    end {hex} ;

    function DOSversion : Byte;
      {-return the major version number of DOS}
    var
      reg : registers;
    begin
      reg.ah := $30;
      MsDos(reg);
      DOSversion := reg.al;
    end {dosversion} ;

    function Owner(startadd : Integer) : Pathname;
      {-return the name of the owner program of an MCB}
    type
      chararray = array[0..32767] of Char;
    var
      e : ^chararray;
      i : Integer;
      t : Pathname;

      function LongPos(m : Pathname; var s : chararray) : Integer;
        {-return the position number of m in s, or 0 if not found}
      var
        mc : Char;
        ss : Pathname;
        i, maxindex : Integer;
        found : Boolean;
      begin
        i := 0;
        maxindex := SizeOf(s)-Length(m);
        ss[0] := m[0];
        if Length(m) > 0 then begin
          mc := m[1];
          repeat
            while (s[i] <> mc) and (i <= maxindex) do
              i := Succ(i);
            if s[i] = mc then begin
              Move(s[i], ss[1], Length(m));
              found := (ss = m);
              if not(found) then i := Succ(i);
            end;
          until found or (i > maxindex);
          if not(found) then i := 0;
        end;
        LongPos := i;
      end {longpos} ;

      procedure StripPathname(var pname : Pathname);
        {-remove leading drive or path name from the input}
      var
        spos, cpos, rpos : Byte;
      begin
        spos := Pos('\', pname);
        cpos := Pos(':', pname);
        if spos+cpos = 0 then Exit;
        if spos <> 0 then begin
          {find the last slash in the pathname}
          rpos := Length(pname);
          while (rpos > 0) and (pname[rpos] <> '\') do rpos := Pred(rpos);
        end else
          rpos := cpos;
        Delete(pname, 1, rpos);
      end {strippathname} ;

      procedure StripExtension(var pname : Pathname);
        {-remove the file extension}
      var
        dotpos : Byte;
      begin
        dotpos := Pos('.', pname);
        if dotpos <> 0 then
          Delete(pname, dotpos, 64); {<255 needed for Turbo version 3.00B bug}
      end {stripextension} ;

    begin
      {point to the environment string}
      e := Ptr(startadd, 0);

      {find end of the standard environment}
      i := LongPos(#0#0, e^);
      if i = 0 then begin
        {something's wrong, exit gracefully}
        Owner := '';
        Exit;
      end;

      {end of environment found, get the program name that follows it}
      t := '';
      i := i+4;               {skip over #0#0#args}
      repeat
        t := t+e^[i];
        i := Succ(i);
      until (Length(t) > 64) or (e^[i] = #0);

      StripNonAscii(t);
      if t = '' then
        Owner := 'N/A'
      else begin
        StripPathname(t);
        StripExtension(t);
        if t = '' then t := 'N/A';
        Owner := StUpcase(t);
      end;

    end {owner} ;

    procedure InitVectorTable;
      {-build real equivalent of vector addresses}
    var
      v : VectorType;

      function RealAdd(a : Address) : Real;
        {-return the real equivalent of an address (pointer)}
      begin
        with a do
          RealAdd := 16.0*Cardinal(segment)+Cardinal(offset);
      end {realadd} ;

    begin
      for v := 0 to MaxVector do
        Vtable[v] := RealAdd(Vectors[v]);
    end {initvectortable} ;

    procedure WriteVecs(start, stop, startcol, wrapcol : Integer);
      {-Show either trapped or chained interrupt vectors}

      procedure WriteHooks(start, stop, startcol, wrapcol : Integer);
        {-show the trapped interrupt vectors}
      var
        v : VectorType;
        sadd, eadd : Real;
        col : Integer;
      begin
        sadd := 16.0*Cardinal(start);
        eadd := 16.0*Cardinal(stop);
        col := startcol;
        for v := 0 to MaxVector do
          if (Vtable[v] >= sadd) and (Vtable[v] <= eadd) then begin
            if col+3 > wrapcol then begin
              {wrap to next line}
              WriteLn;
              Write('':Pred(startcol));
              col := startcol;
            end;
            Write(HexB(v), ' ');
            col := col+3;
          end;
      end {writehooks} ;

      procedure WriteChained(pspA, startcol, wrapcol : Integer);
        {-Write Chained interrupts as determined from watch data}
      type
        ChangeBlock =
        record                {Store info about each vector takeover}
          VecNum : Byte;
          case ID : Byte of
            0, 1 : (VecOfs, VecSeg : Integer);
            2 : (SaveCode : array[1..6] of Byte);
            $FF : (pspAdd : Integer);
        end;
        {
        ID is interpreted as follows:
        00 = ChangeBlock holds the new pointer for vector vecnum
        01 = ChangeBlock holds pointer for vecnum but the block is disabled
        02 = ChangeBlock holds the code underneath the vector patch
        FF = ChangeBlock holds the segment of a new PSP
        }
      var
        p : ^ChangeBlock;
        i, maxchg, col : Integer;
        found : Boolean;
      begin
        {Initialize}
        maxchg := MemW[WatchPSP:NextChange];
        col := startcol;
        found := False;
        i := 0;

        while i < maxchg do begin
          p := Ptr(WatchPSP, ChangeVectors+i);
          with p^ do
            case ID of
              $FF :           {ChangeBlock starts a new PSP}
                found := (pspA = pspAdd);
              $00 :           {ChangeBlock describes an active vector takeover}
                if found then begin
                  {ChangeBlock specifies a vector taken over}
                  if col >= wrapcol then begin
                    Write(^M^J, '':Pred(startcol));
                    col := startcol;
                  end;
                  Write(HexB(Lo(VecNum)), ' ');
                  col := col+3;
                end;
              $01 :           {ChangeBlock specifies a disabled takeover}
                if found then begin
                  Write('disabled');
                  {Don't write this more than once}
                  Exit;
                end;
            end;
          i := i+SizeOf(ChangeBlock);
        end;
      end {WriteChained} ;

    begin
      if start <> stop then
        if UseWatch then
          WriteChained(start, startcol, wrapcol)
        else
          WriteHooks(start, stop, startcol, wrapcol);
    end {WriteVecs} ;

    procedure SortByPSP(var Blocks : BlockArray; BlockNum : BlockType);
      {-sort in order of ascending PSP}
    var
      i, j : BlockType;
      temp : Block;
    begin
      for i := 1 to Pred(BlockNum) do
        for j := BlockNum downto Succ(i) do
          if Cardinal(Blocks[j].psp) < Cardinal(Blocks[Pred(j)].psp) then begin
            temp := Blocks[j];
            Blocks[j] := Blocks[Pred(j)];
            Blocks[Pred(j)] := temp;
          end;
    end {SortByPSP} ;

    procedure SumTheBlocks(var Blocks : BlockArray;
                           BlockNum : BlockType;
                           var Sum : BlockArray;
                           var SumNum : BlockType);
      {-combine the blocks with equivalent PSPs}
    var
      prevPSP : Integer;
      b : BlockType;
    begin
      SumNum := 0;
      prevPSP := 0;
      for b := 1 to BlockNum do begin
        if Blocks[b].psp <> prevPSP then begin
          SumNum := Succ(SumNum);
          Sum[SumNum] := Blocks[b];
          prevPSP := Blocks[b].psp;
          if prevPSP = CSeg then
            {don't include the environment as part of free block's length}
            Sum[SumNum].len := 0;
        end else
          with Sum[SumNum] do begin
            cnt := Succ(cnt);
            len := len+Blocks[b].len;
          end;
        {get length of the block which owns the executable program}
        {for checking vector trapping next}
        if Succ(Blocks[b].mcb) = Blocks[b].psp then
          Sum[SumNum].psplen := Blocks[b].len;
      end;
    end {sumtheblocks} ;

    procedure TransferTheBlocks(var Blocks : BlockArray;
                                BlockNum : BlockType;
                                var Sum : BlockArray;
                                var SumNum : BlockType);
      {-fill in the Sum array with a little initialization}
    var
      b : BlockType;
    begin
      for b := 1 to BlockNum do begin
        Sum[b] := Blocks[b];
        with Sum[b] do begin
          cnt := 1;
          if (Succ(mcb) = psp) and (psp <> 0) then
            psplen := len
          else
            psplen := 0;
        end;
      end;
      SumNum := BlockNum;
    end {transfertheblocks} ;

    function OpenHandles(psp : Integer) : Integer;
      {-return the number of open handles owned by a process}
    var
      h, o : Integer;
      b : Byte;
    begin
      h := 0;
      if (psp <> 8) and (cline <> 'N/A') then
        for o := 0 to 19 do begin
          b := Mem[psp:$18+o];
          if not(b in [$FF, 0..2]) then
            h := Succ(h);
        end;
      OpenHandles := h;
    end {openhandles} ;

    function CommandLine(psp : Integer) : Pathname;
      {-return the command line of the PSP}
    var
      t, s : Pathname;
    begin
      if (psp <> 8) then begin
        Move(Mem[psp:$80], t, 65);
        if t[0] > #64 then t[0] := #64;
        s := t;
        StripNonAscii(t);
        if s <> t then
          {command line has been written over}
          t := 'N/A'
        else
          {strip leading blanks}
          while (Length(t) > 0) and (t[1] = #32) do Delete(t, 1, 1);
      end else
        {psp=8 is a special block owned by DOS containing the CONFIG.SYS drivers}
        t := '';
      CommandLine := t;
    end {commandline} ;

    function PrevBlock(b : BlockType; psp : Integer) : BlockType;
      {-return highest block with number less than b having a PSP matching psp}
      {-return 0 if none}
    var
      t : BlockType;
      found : Boolean;
    begin
      found := False;
      t := Pred(b);
      while (t > 0) and not(found) do begin
        found := (Sum[t].psp = psp);
        if not(found) then t := Pred(t);
      end;
      PrevBlock := t;
    end {prevblock} ;

    procedure WriteTitle;
    begin
      Write('Allocated Memory Map - by TurboPower Software - Version ', Version);

      if Verbose then begin
        WriteLn('  (verbose)');
        WriteLn;
        Write(' PSP  MCB files bytes owner    command line  ');
        if UseWatch then
          WriteLn(chainst)
        else
          WriteLn(hookst);
        WriteLn('---- ---- ----- ----- -------- ------------- -----------------------------');
      end else begin
        WriteLn;
        WriteLn;
        Write(' PSP  blks bytes owner    command line        ');
        if UseWatch then
          WriteLn(chainst)
        else
          WriteLn(hookst);
        WriteLn('----- ---- ----- -------- ------------------- ------------------------------');
      end;
    end {WriteTitle} ;

  begin

    WriteTitle;

    {Get critical PSP addresses before sorting blocks}
    CommandPSP := Blocks[2].psp;
    if UseWatch then
      WatchPSP := Blocks[WatchBlock].psp
    else
      InitVectorTable;

    {Rearrange the blocks for presentation}
    if Verbose then
      TransferTheBlocks(Blocks, BlockNum, Sum, SumNum)
    else begin
      SortByPSP(Blocks, BlockNum);
      SumTheBlocks(Blocks, BlockNum, Sum, SumNum);
    end;

    {Get DOS version number to see whether environment has program names}
    DOSv := DOSversion;

    for b := 1 to SumNum do with Sum[b] do begin

      {get the command line which invoked the program}
      if b = SumNum then
        cline := ''
      else
        cline := CommandLine(psp);

      {write out numerical information}
      Write(Hex(psp), ' ');   {PSP address}
      if Verbose then begin
        Write(Hex(mcb), '  ', {MCB address}
        OpenHandles(psp):2, '  '); {number of open file handles}
      end else
        Write(cnt:3, '  ');   {number of blocks}

      Write(16.0*Cardinal(len):6:0, ' '); {size of block in bytes}

      {get the program owning this block by scanning the environment}
      if psp = CSeg then
        st := 'free'
      else if psp = CommandPSP then
        st := 'command'
      else if psp = Sum[1].psp then
        st := 'config'
      else if (DOSv >= 3) then begin
        if Verbose then begin
          if Succ(mcb) = env then
            {this is the environment block}
            st := Owner(env)
          else if PrevBlock(b, psp) <> 0 then
            {this is the block that goes with the environment}
            st := Owner(Sum[PrevBlock(b, psp)].env)
          else
            st := 'N/A';
        end else if cnt > 1 then
          st := Owner(env)
        else
          st := 'N/A';
      end else
        st := 'N/A';
      while Length(st) < 9 do
        st := st+' ';
      Write(st);

      {write the command line that invoked the program}
      if Verbose then
        StLen := 13
      else
        StLen := 19;
      if Length(cline) > StLen-3 then
        cline := Copy(cline, 1, StLen-3)+'...'
      else
        while Length(cline) < StLen do cline := cline+' ';
      Write(cline, ' ');

      {write the trapped interrupt vectors}
      if Verbose then
        WriteVecs(psp, psp+psplen, 46, 75)
      else if (b <> SumNum) then
        WriteVecs(psp, psp+psplen, 47, 75);

      WriteLn;
    end;

  end {showtheblocks} ;

  procedure ShowTheEMSblocks;
    {-map out expanded memory, if present}
  const
    EMSinterrupt = $67;       {the vector used by the expanded memory manager}
    MaxHandles = 255;

  type
    HandlePageRecord =
    record
      handle : Integer;
      numpages : Integer;
    end;

    PageArray = array[0..MaxHandles] of HandlePageRecord;
    PageArrayPtr = ^PageArray;
    Pathname = string[64];

  var
    EMSregs : registers;
    EMShandles : Integer;
    Map : PageArrayPtr;
    TotalPages : Integer;

    function EMSpresent : Boolean;
      {-return true if EMS memory manager is present}
    var
      f : file;
      present : Boolean;
    begin
      {"file handle" defined by the expanded memory manager at installation}
      Assign(f, 'EMMXXXX0');
      {$I-} Reset(f) {$I+} ;
      present := (IOResult = 0);
      if present then
        Close(f);
      EMSpresent := present;
    end {EMSpresent} ;

    function EMSpagesAvailable(var TotalPages : Integer) : Integer;
      {-return the number of 16K expanded memory pages available and unallocated}
    begin
      EMSregs.ah := $42;
      Intr(EMSinterrupt, EMSregs);
      if EMSregs.ah <> 0 then begin
        WriteLn('EMS device not responding');
        EMSpagesAvailable := 0;
        Exit;
      end;
      EMSpagesAvailable := EMSregs.bx;
      TotalPages := EMSregs.dx;
    end {EMSpagesAvailable} ;

    procedure EMSpageMap(var PageMap : PageArray; var EMShandles : Integer);
      {-return an array of the allocated memory blocks}
    begin
      EMSregs.ah := $4D;
      EMSregs.es := Seg(PageMap);
      EMSregs.di := Ofs(PageMap);
      EMSregs.bx := 0;
      Intr(EMSinterrupt, EMSregs);
      if EMSregs.ah <> 0 then begin
        WriteLn('EMS device not responding');
        EMShandles := 0;
      end else
        EMShandles := EMSregs.bx;
    end {EMSpageMap} ;

    procedure WriteEMSmap(PageMap : PageArray; handles : Integer);
      {-write out the EMS page map}
    var
      h : Integer;
    begin
      WriteLn('block   bytes   (Expanded Memory)');
      WriteLn('-----   ------');
      for h := 0 to Pred(handles) do
        WriteLn(h:5, '  ', (16384.0*Cardinal(PageMap[h].numpages)):7:0);
    end {writeEMSmap} ;

  begin
    if not(EMSpresent) then
      Exit;
    WriteLn;
    {Get space for the largest possible page map}
    GetMem(Map, 2048);
    EMSpageMap(Map^, EMShandles);
    WriteEMSmap(Map^, EMShandles);
    WriteLn(' free  ', (16384.0*Cardinal(EMSpagesAvailable(TotalPages))):7:0);
    WriteLn('total  ', (16384.0*Cardinal(TotalPages)):7:0);
  end {showtheemsblocks} ;

  procedure GetOptions;
    {-Analyze command line for options}
  const
    unknop : string[24] = 'Unknown command option: ';
  var
    arg : AllStrings;
    arglen : Byte absolute arg;
    i : Integer;

    procedure WriteHelp;
      {-Show the options}
    begin
      WriteLn('MAPMEM ', Version, ', by TurboPower Software');
      WriteLn('====================================================');
      WriteLn;
      WriteLn('MAPMEM produces a report showing what memory resident');
      WriteLn('programs are installed, how much memory each uses, and');
      WriteLn('what interrupt vectors are taken over.');
      WriteLn;
      WriteLn('MAPMEM accepts the following command line syntax:');
      WriteLn;
      WriteLn('  MAPMEM [Options]');
      WriteLn;
      WriteLn('Options may be preceded by either / or -. Valid options');
      WriteLn('are as follows:');
      WriteLn('     /V     Verbose report.');
      WriteLn('     /?     Write this help screen.');
      Halt(1);
    end {WriteHelp} ;

  begin

    WriteLn;
    {Initialize defaults}
    Verbose := False;
    UseHook := False;

    i := 1;
    while i <= ParamCount do begin
      arg := ParamStr(i);
      if (arg[1] = '?') then
        WriteHelp
      else if (arg[1] = '-') or (arg[1] = '/') then
        case arglen of
          1 : Abort('Missing command option following '+arg);
          2 : case UpCase(arg[2]) of
                '?' : WriteHelp;
                'H' : UseHook := True;
                'V' : Verbose := True;
              else
                Abort(unknop+arg);
              end;
        else
          Abort(unknop+arg);
        end
      else
        Abort(unknop+arg);
      i := Succ(i);
    end;

  end {GetOptions} ;

begin                         {MapMem}
  GetOptions;
  FindTheBlocks;
  WatchBlock := FindMark(WatchID, WatchOffset);
  UseWatch := UseWatch and not(UseHook);
  ShowTheBlocks;
  ShowTheEMSblocks;
end.                          {MapMem}